{-# LANGUAGE ScopedTypeVariables        #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Majalan.Base.Trail
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Timed impulses with labels.
-- 
-- InterimIM for elemetary building, ImpulseMap for processing 
-- and transforming.
-- 
--------------------------------------------------------------------------------

module Majalan.Base.Trail
  (

    Trail
  , GenTrail
  , execTrail
  , insert
  , incrPos
  , displaceTrail

  , fromOnsets
  , fromDurations

  , divisiveTrail  
  , deceleratingTrail
  , acceleratingTrail

  , mapTrail
  , stmapTrail

  , numberTrail

  ) where

import Majalan.Base.Internal.Base
import Majalan.Base.Internal.Utils

import Control.Applicative hiding ( empty )
import Control.Monad
import qualified Data.Map as M
import Data.Monoid




type CursorPos = Seconds

type Acc impl = HMap Seconds impl



type Trail impl = GenTrail impl ()

newtype GenTrail impl a = GenTrail { 
    getGenTrail :: CursorPos -> (CursorPos, Acc impl, a) }

-- Note - there is another formulation with initial onset (Reader)
-- rather than cursor pos (State) - the Map in this case should 
-- track deltas. Unfortunately this formulation has good 
-- displacement but doesn\'t support serial concat.



instance Functor (GenTrail impl) where
  fmap f ma = GenTrail $ \s -> 
      let (s1,w1,a) = getGenTrail ma s in (s1,w1,f a)

instance Applicative (GenTrail impl) where
  pure a    = GenTrail $ \s -> (s, emptyHMap, a)
  mf <*> ma = GenTrail $ \s -> 
                let (s1,w1,f) = getGenTrail mf s
                    (s2,w2,a) = getGenTrail ma s1
                in (s2, w1 `appendHMap` w2, f a)

instance Monad (GenTrail impl) where
  return    = pure
  ma >>= k  = GenTrail $ \s-> 
                let (s1,w1,a) = getGenTrail ma s
                    (s2,w2,b) = getGenTrail (k a) s1
                in (s2, w1 `appendHMap` w2, b)

instance Monoid a => Monoid (GenTrail impl a) where
  mempty          = GenTrail $ \s -> (s, emptyHMap, mempty) 
  ma `mappend` mb = GenTrail $ \s -> 
                      let (s1,w1,a) = getGenTrail ma s
                          (s2,w2,b) = getGenTrail mb s1
                      in (s2, w1 `appendHMap` w2, a <> b)


execTrail :: Seconds -> Trail impl -> M.Map Seconds impl
execTrail t0 ma = let (_,imps,_)  = getGenTrail ma t0 in toMapH imps


insert :: Seconds -> a -> Trail a
insert delta a = GenTrail $ \s -> 
    let t1 = s + delta in (t1, singletonHMap t1 a, () )

incrPos :: Seconds -> Trail a
incrPos delta = GenTrail $ \s -> 
    let t1 = s + delta in (t1, emptyHMap, () )

displaceTrail :: Seconds -> GenTrail a o -> GenTrail a o
displaceTrail dt ma = GenTrail $ \s -> getGenTrail ma (s + dt)


fromOnsets :: [Seconds] -> a -> Trail a
fromOnsets []     _ = return ()
fromOnsets (t:ts) a = insert t a >> step t ts
  where
    step _  []      = return ()
    step t0 (x:xs)  = insert (x - t0) a >> step x xs

fromDurations :: [Seconds] -> a -> Trail a
fromDurations ts a  = step ts
  where
    step []      = return ()
    step (x:xs)  = insert 0 a >> incrPos x >> step xs


divisiveTrail :: Int -> Seconds -> a -> Trail a
divisiveTrail n totd a = let d1 = totd / fromIntegral n in 
    replicateM_ n $ insert 0 a >> incrPos d1



deceleratingTrail :: Int -> Seconds -> a -> Trail a
deceleratingTrail n totd a = fromDurations (decelLengths n totd) a

decelLengths :: Int -> Seconds -> [Seconds]
decelLengths n totd = 
    let unitc   = (two ^ n) - 1
        unitd   = totd / fromIntegral unitc
        ixs     = [0.. (n-1)]
    in map (\i -> unitd * fromIntegral (two ^ i)) ixs
  where
    two ::Integer
    two = 2


acceleratingTrail :: Int -> Seconds -> a -> Trail a
acceleratingTrail n totd a = fromDurations (reverse $ decelLengths n totd) a




mapTrail :: (a -> b) -> GenTrail a o -> GenTrail b o
mapTrail fn ma = GenTrail $ \s -> 
    let (s1,w1,o) = getGenTrail ma s in (s1, fromMapH $ M.map fn $ toMapH w1, o)


stmapTrail :: (st -> a -> (st,b)) -> st -> GenTrail a o -> GenTrail b (st,o)
stmapTrail fn st0 ma = GenTrail $ \s -> 
    let (s1,w1,o) = getGenTrail ma s 
        xs        = M.toAscList $ toMapH w1
        (st1,ys)  = step st0 xs
    in (s1, fromMapH $ M.fromAscList ys, (st1,o))
  where
    step st []          = (st, [])
    step st ((t,a):as)  = let (st1,b)  = fn st a 
                              (st2,ys) = step st1 as
                          in (st2, (t,b):ys)


numberTrail :: Int -> GenTrail a o -> GenTrail Int o
numberTrail start ma = snd <$> stmapTrail fn start ma
  where
    fn i _ = (i+1,i)